home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / amok_lha / amok33.lha / ImageConvert / ImageConvert.mod < prev    next >
Text File  |  1993-08-15  |  12KB  |  363 lines
  1. (* ------------------------------------------------------------------------
  2.   :Program.       ImageConvert
  3.   :Author.        Kai Bolay
  4.   :Address.       Hoffmannstraße 168
  5.   :Address.       7250 Leonberg 1
  6.   :Phone.         07152/22135
  7.   :Copyright.     PublicDomain
  8.   :History.       v1.0 25-Nov-89 Initial Version on Amok#29
  9.   :History.       v1.1 14-Feb-90 ColorTable/v3.3 Support
  10.   :Language.      Modula-2
  11.   :Translator.    M2Amiga 3.3d
  12.   :Imports.       IFFSupport1.5 [fbs], InOut2 [Bernd Preusing]
  13.   :Contents.      Umwandlung von IFF-Brushes in M2-Source-Code.
  14. ------------------------------------------------------------------------ *)
  15.  
  16. MODULE ImageConvert;
  17.  
  18. (* FOLD: IMPORT *)
  19. FROM SYSTEM     IMPORT ADR, ADDRESS;
  20. FROM Arts       IMPORT Assert, TermProcedure, Terminate;
  21. FROM Arguments  IMPORT NumArgs, GetArg;
  22. FROM Str        IMPORT Copy, Concat;
  23. FROM FileNames  IMPORT GetPath;
  24. FROM IFFSupport IMPORT ReadILBM, ReadILBMFlags, ReadILBMFlagSet, IFFInfo;
  25. FROM InOut2     IMPORT SetOutput, WriteString, WriteLn, WriteCard,
  26.                        ReadString, done, CloseOutput, WriteHex, WriteInt;
  27. FROM Graphics   IMPORT RastPortPtr, BitMapPtr, ViewModes, ViewModeSet;
  28. FROM Icon       IMPORT GetDiskObject, PutDiskObject, FreeDiskObject;
  29. FROM Workbench  IMPORT DiskObjectPtr;
  30. FROM Intuition  IMPORT ScreenPtr, CloseScreen, WindowPtr, DisplayBeep;
  31. (* ENDFD *)
  32.  
  33. VAR num, len         : INTEGER;
  34.     Output, Argument : ARRAY [1..200] OF CHAR;
  35.     ynStr            : ARRAY [1..5] OF CHAR;
  36.     NewCompi, Table  : BOOLEAN;
  37.     DefOpen, ModOpen : BOOLEAN;
  38.     MyScreen         : ScreenPtr;
  39.  
  40. (* FOLD: MakeIcon *)
  41. PROCEDURE MakeIcon (name : ARRAY OF CHAR);
  42.  
  43. CONST IconName = "M2:Icons/txt";
  44.  
  45. VAR Icon : DiskObjectPtr;
  46.  
  47. BEGIN
  48.    Icon := GetDiskObject (ADR (IconName));
  49.    IF Icon # NIL THEN
  50.       IF PutDiskObject (ADR (name), Icon) THEN END;
  51.       FreeDiskObject (Icon);
  52.    END; (* IF *)
  53. END MakeIcon;
  54. (* ENDFD *)
  55. (* FOLD: WriteName *)
  56. PROCEDURE WriteName (name : ARRAY OF CHAR);
  57.  
  58. VAR path : ARRAY [0..100] OF CHAR;
  59.     len  : INTEGER;
  60.  
  61. BEGIN
  62.    GetPath (name, path, len);
  63.    WriteString (name);
  64. END WriteName;
  65. (* ENDFD *)
  66. (* FOLD: CloseDef *)
  67. PROCEDURE CloseDef;
  68.  
  69. BEGIN
  70.    IF DefOpen THEN
  71.       CloseOutput ();
  72.    END; (* IF *)
  73. END CloseDef;
  74. (* ENDFD *)
  75. (* FOLD: OpenDef *)
  76. PROCEDURE OpenDef;
  77.  
  78. VAR DefName : ARRAY [1..200] OF CHAR;
  79.  
  80. BEGIN
  81.    TermProcedure (CloseDef);
  82.    Copy (DefName, Output);
  83.    Concat (DefName, ".def");
  84.    SetOutput (DefName);
  85.    DefOpen := done;
  86.    Assert (DefOpen, ADR ("Can't open DEFINITION-File!"));
  87.    MakeIcon (DefName);
  88. END OpenDef;
  89. (* ENDFD *)
  90. (* FOLD: CloseMod *)
  91. PROCEDURE CloseMod;
  92.  
  93. BEGIN
  94.    IF ModOpen THEN
  95.       CloseOutput ();
  96.    END; (* IF *)
  97. END CloseMod;
  98. (* ENDFD *)
  99. (* FOLD: OpenMod *)
  100. PROCEDURE OpenMod;
  101.  
  102. VAR ModName : ARRAY [1..200] OF CHAR;
  103.  
  104. BEGIN
  105.    TermProcedure (CloseMod);
  106.    Copy (ModName, Output);
  107.    Concat (ModName, ".mod");
  108.    SetOutput (ModName);
  109.    ModOpen := done;
  110.    Assert (ModOpen, ADR ("Can't open IMPLEMENTATION-File!"));
  111.    MakeIcon (ModName);
  112. END OpenMod;
  113. (* ENDFD *)
  114. (* FOLD: WriteModProcs *)
  115. PROCEDURE WriteModProcs (name : ARRAY OF CHAR);
  116.  
  117. VAR Depth, Width, Height,
  118.     ByteWidth, ScrByteWidth : INTEGER;
  119.     RP                      : RastPortPtr;
  120.     BM                      : BitMapPtr;
  121.     Plane, Line, Step, col  : INTEGER;
  122.     MyWindow                : WindowPtr;
  123.     NewLine                 : BOOLEAN;
  124.     Location                : POINTER TO CARDINAL;
  125.     Num                     : CARDINAL;
  126.  
  127.    (* FOLD: NumColors *)
  128.    PROCEDURE NumColors() : CARDINAL; (* ColorMap.count will nicht recht! *)
  129.  
  130.    VAR c, t : CARDINAL;
  131.  
  132.    BEGIN
  133.       c := 1; t := MyScreen^.bitMap.depth;
  134.       WHILE t > 0 DO c := c * 2; DEC (t); END;
  135.       IF (ham IN MyScreen^.viewPort.modes) THEN c := 16 END;
  136.       IF (extraHalfbrite IN MyScreen^.viewPort.modes) THEN
  137.          c := 32;
  138.       END; (* IF *)
  139.       RETURN c;
  140.    END NumColors;
  141.    (* ENDFD *)
  142.  
  143. BEGIN
  144.    IF NOT (ReadILBM (name, ReadILBMFlagSet {visible}, MyScreen, MyWindow)) THEN
  145.       DisplayBeep (NIL);
  146.    ELSE
  147.       WITH IFFInfo.BMHD DO
  148.          Depth  := depth;
  149.          Width  := width;
  150.          Height := height;
  151.       END; (* WITH *)
  152.       ByteWidth := Width DIV 8;
  153.       IF (ByteWidth * 8) < Width THEN
  154.          INC (ByteWidth);
  155.       END; (* IF *)
  156.       IF ODD (ByteWidth) THEN
  157.          INC (ByteWidth);
  158.       END; (* IF *)
  159.       WITH MyScreen^ DO
  160.          ScrByteWidth := width DIV 8;
  161.          RP := ADR (rastPort);
  162.          BM := RP^.bitMap;
  163.       END; (* WITH *)
  164.  
  165.       WriteLn;
  166.       WriteString ("(* $E- *)"); WriteLn;
  167.       WriteString ("PROCEDURE "); WriteName (name); WriteString ("Dat;");
  168.       WriteLn; WriteLn;
  169.       WriteString ("BEGIN"); WriteLn;
  170.       FOR Plane := 0 TO Depth-1 DO
  171.          WriteString ("   (* Plane "); WriteInt (Plane+1, 1);
  172.          WriteString (" *)"); WriteLn;
  173.          NewLine := TRUE;
  174.          FOR Line := 0 TO Height-1 DO
  175.             FOR Step := 0 TO ByteWidth-2 BY 2 DO
  176.                IF NewLine THEN
  177.                   WriteString ("   INLINE (");
  178.                   NewLine := FALSE;
  179.                   Num := 0;
  180.                END; (* IF *)
  181.                WriteString ("0");
  182.                Location := ADDRESS (BM^.planes[Plane] + Step +
  183.                                     ScrByteWidth * Line);
  184.                WriteHex (Location^, 4); WriteString ("H");
  185.                INC (Num);
  186.                IF (Num = 8) OR
  187.                   ((Step = ByteWidth-2) AND (Line = Height-1)) THEN
  188.                   WriteString (");"); WriteLn; NewLine := TRUE;
  189.                ELSE
  190.                   WriteString (", ");
  191.                END; (* IF *)
  192.             END; (* FOR Step *)
  193.          END; (* FOR Line *)
  194.       END; (* FOR Plane *)
  195.       WriteString ("END "); WriteName (name); WriteString ("Dat;"); WriteLn;
  196.       WriteLn; WriteLn;
  197.       IF Table THEN
  198.          WriteString ("(* $E- *)"); WriteLn;
  199.          WriteString ("PROCEDURE "); WriteName (name); WriteString ("Tab;");
  200.          WriteLn; WriteLn;
  201.          WriteString ("BEGIN"); WriteLn;
  202.          NewLine := TRUE;
  203.          FOR col := 0 TO NumColors()-1 DO
  204.             IF NewLine THEN
  205.                WriteString ("   INLINE (");
  206.                NewLine := FALSE;
  207.                Num := 0;
  208.             END; (* IF *)
  209.             WriteString ("0");
  210.             Location := ADDRESS (MyScreen^.viewPort.colorMap^.colorTable +
  211.                                  LONGINT (col) * 2);
  212.             WriteHex (Location^, 4); WriteString ("H");
  213.             INC (Num);
  214.             IF (Num = 8) OR
  215.                (col = INTEGER (NumColors()-1)) THEN
  216.                WriteString (");"); WriteLn; NewLine := TRUE;
  217.             ELSE
  218.                WriteString (", ");
  219.             END; (* IF *)
  220.          END; (* FOR *)
  221.          WriteString ("END "); WriteName (name); WriteString ("Tab;");
  222.          WriteLn; WriteLn; WriteLn;
  223.       END; (* IF *)
  224.       WriteString ("PROCEDURE Init"); WriteName (name); WriteString (";");
  225.       WriteLn; WriteLn;
  226.       IF NOT (NewCompi) THEN
  227.          WriteString ("CONST "); WriteName (name); WriteString ("Size =");
  228.          WriteInt (Height * ByteWidth * Depth, 5); WriteString (";");
  229.          WriteLn; WriteLn;
  230.       END; (* IF *)
  231.       WriteString ("BEGIN"); WriteLn;
  232.       WriteString ("   WITH "); WriteName (name); WriteString (" DO");
  233.       WriteLn;
  234.       WriteString ("      leftEdge   := 0;"); WriteLn;
  235.       WriteString ("      topEdge    := 0;"); WriteLn;
  236.       WriteString ("      width      := "); WriteInt (Width, 3);
  237.       WriteString (";"); WriteLn;
  238.       WriteString ("      height     := "); WriteInt (Height, 3);
  239.       WriteString (";"); WriteLn;
  240.       WriteString ("      depth      := "); WriteInt (Depth, 1);
  241.       WriteString (";"); WriteLn;
  242.       IF NewCompi THEN
  243.          WriteString ("      imageData  := ADR ("); WriteName (name);
  244.          WriteString ("Dat);"); WriteLn;
  245.       END; (* IF *)
  246.       WriteString ("      planePick  := 255;"); WriteLn;
  247.       WriteString ("      planeOnOff := 0;"); WriteLn;
  248.       WriteString ("      nextImage  := NIL;"); WriteLn;
  249.       IF NOT (NewCompi) THEN
  250.          WriteString ("      AllocMem (imageData, "); WriteName (name);
  251.          WriteString ("Size, TRUE);"); WriteLn;
  252.          WriteString ("      CopyMem (ADR ("); WriteName (name);
  253.          WriteString ("Dat), imageData, "); WriteName (name);
  254.          WriteString ("Size);"); WriteLn;
  255.       END; (* IF *)
  256.       WriteString ("   END; (* WITH *)"); WriteLn;
  257.       IF Table THEN
  258.          WriteString ("   WITH "); WriteName (name); WriteString ("Col DO");
  259.          WriteLn;
  260.          WriteString ("      flags      := ");
  261.          WriteCard (MyScreen^.viewPort.colorMap^.flags, 3); WriteString (";");
  262.          WriteLn;
  263.          WriteString ("      type       := ");
  264.          WriteCard (MyScreen^.viewPort.colorMap^.type, 3); WriteString (";");
  265.          WriteLn;
  266.          WriteString ("      count      := ");
  267.          WriteCard (NumColors(), 3); WriteString (";");
  268.          WriteLn;
  269.          WriteString ("      colorTable := ADR ("); WriteName (name);
  270.          WriteString ("Tab);"); WriteLn;
  271.          WriteString ("   END; (* WITH *)"); WriteLn;
  272.       END; (* IF *)
  273.       WriteString ("END Init"); WriteName (name); WriteString (";");
  274.       WriteLn;
  275.       CloseScreen (MyScreen); MyScreen := NIL;
  276.    END; (* IF *)
  277. END WriteModProcs;
  278. (* ENDFD *)
  279. (* FOLD: CleanUp *)
  280. PROCEDURE CleanUp;
  281.  
  282. BEGIN
  283.    IF MyScreen # NIL THEN
  284.       CloseScreen (MyScreen);
  285.       MyScreen := NIL;
  286.    END; (* IF *)
  287. END CleanUp;
  288. (* ENDFD *)
  289.  
  290. BEGIN
  291.    TermProcedure (CleanUp);
  292.    WriteString ("Image Convert 1.1.  © 1989-90 by Kai Bolay"); WriteLn;
  293.    WriteLn;
  294.    IF NumArgs() = 0 THEN
  295.       WriteString ("No Input!"); WriteLn;
  296.       Terminate (0);
  297.    END; (* IF *)
  298.    REPEAT
  299.       WriteString ("Compiler-Version >3.2 (y/n) ? ");
  300.       ReadString (ynStr);
  301.    UNTIL (ynStr[1] = 'y') OR (ynStr[1] = 'n');
  302.    NewCompi := ynStr[1] = 'y';
  303.    REPEAT
  304.       WriteString ("Generate Colortable ? ");
  305.       ReadString (ynStr);
  306.    UNTIL (ynStr[1] = 'y') OR (ynStr[1] = 'n');
  307.    Table := (ynStr[1] = 'y');
  308.    WriteString ("Name of Module to be generated (without Suffix): ");
  309.    ReadString (Output);
  310.    (* FOLD: DEFINITION *)
  311.    OpenDef;
  312.    WriteString ("DEFINITION MODULE ");
  313.    WriteName (Output); WriteString (";"); WriteLn;
  314.    WriteLn;
  315.    WriteString ("FROM Intuition IMPORT Image;"); WriteLn;
  316.    IF Table THEN
  317.       WriteString ("FROM Graphics  IMPORT ColorMap;"); WriteLn;
  318.    END; (* IF *)
  319.    WriteLn;
  320.    FOR num := 1 TO NumArgs() DO
  321.       GetArg (num, Argument, len);
  322.       IF num = 1 THEN
  323.          WriteString ("VAR ");
  324.       ELSE
  325.          WriteString ("    ");
  326.       END; (* IF *)
  327.       WriteName (Argument); WriteString (" : Image;"); WriteLn;
  328.       IF Table THEN
  329.          WriteString ("    "); WriteName (Argument);
  330.          WriteString ("Col : ColorMap;"); WriteLn;
  331.       END; (* IF *)
  332.    END; (* FOR *)
  333.    WriteLn;
  334.    WriteString ("END "); WriteName (Output); WriteString ("."); WriteLn;
  335.    CloseDef;
  336.    (* ENDFD *)
  337.    (* FOLD: IMPLEMENTATION *)
  338.    OpenMod;
  339.    WriteString ("IMPLEMENTATION MODULE ");
  340.    WriteName (Output); WriteString (";"); WriteLn;
  341.    WriteLn;
  342.    WriteString ("FROM SYSTEM   IMPORT ADR, INLINE;"); WriteLn;
  343.    IF NOT (NewCompi) THEN
  344.       WriteString ("FROM Heap     IMPORT AllocMem;"); WriteLn;
  345.       WriteString ("FROM Exec     IMPORT CopyMem;"); WriteLn;
  346.    END; (* IF *)
  347.    FOR num := 1 TO NumArgs() DO
  348.       GetArg (num, Argument, len);
  349.       WriteModProcs (Argument);
  350.    END; (* FOR *)
  351.    WriteLn; WriteString ("BEGIN"); WriteLn;
  352.    FOR num := 1 TO NumArgs() DO
  353.       GetArg (num, Argument, len);
  354.       WriteString ("  Init"); WriteName (Argument); WriteString (";");
  355.       WriteLn;
  356.    END; (* FOR *)
  357.    WriteString ("END "); WriteName (Output); WriteString ("."); WriteLn;
  358.    CloseMod;
  359.    (* ENDFD *)
  360.    WriteLn;
  361.    WriteString ("Done. Have Fun!"); WriteLn;
  362. END ImageConvert.
  363.